home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / VOTING.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  11KB  |  443 lines

  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2.  
  3. unit voting;
  4.  
  5. interface
  6.  
  7. uses windows,gentypes,gensubs,subs1,subs2,userret,overret1;
  8.  
  9. procedure votingbooth (getmandatory:boolean);
  10.  
  11. implementation
  12.  
  13. procedure votingbooth (getmandatory:boolean);
  14. var curtopic:topicrec;
  15.     curtopicnum:integer;
  16.  
  17.   function votefn (n:integer):sstr;
  18.   begin
  19.     votefn:='VOTEFILE.'+strr(n)
  20.   end;
  21.  
  22.   procedure opentopicdir;
  23.   var n:integer;
  24.   begin
  25.     assign (tofile,'VOTEDIR');
  26.     reset (tofile);
  27.     if ioresult<>0 then begin
  28.       close (tofile);
  29.       n:=ioresult;
  30.       rewrite (tofile)
  31.     end
  32.   end;
  33.  
  34.   function numtopics:integer;
  35.   begin
  36.     numtopics:=filesize (tofile)
  37.   end;
  38.  
  39.   procedure opentopic (n:integer);
  40.   var q:integer;
  41.   begin
  42.     curtopicnum:=n;
  43.     close (chfile);
  44.     assign (chfile,votefn(n));
  45.     reset (chfile);
  46.     if ioresult<>0 then begin
  47.       close (chfile);
  48.       q:=ioresult;
  49.       rewrite (chfile)
  50.     end;
  51.     seek (tofile,n-1);
  52.     read (tofile,curtopic)
  53.   end;
  54.  
  55.   function numchoices:integer;
  56.   begin
  57.     numchoices:=filesize (chfile)
  58.   end;
  59.  
  60.   procedure writecurtopic;
  61.   begin
  62.     seek (tofile,curtopicnum-1);
  63.     write (tofile,curtopic)
  64.   end;
  65.  
  66.   procedure listchoices;
  67.   var ch:choicerec;
  68.       cnt:integer;
  69.   begin
  70.     writehdr ('Your Choices');
  71.     seek (chfile,0);
  72.     for cnt:=1 to numchoices do begin
  73.       read (chfile,ch);
  74.       writeln (cnt:2,'.  ',ch.choice);
  75.       if break then exit
  76.     end
  77.   end;
  78.  
  79.   function addchoice:integer;
  80.   var ch:choicerec;
  81.   begin
  82.     addchoice:=0;
  83.     buflen:=70;
  84.     writestr (^M'Enter new choice:');
  85.     if length(input)<2 then exit;
  86.     addchoice:=numchoices+1;
  87.     ch.numvoted:=0;
  88.     ch.choice:=input;
  89.     seek (chfile,numchoices);
  90.     write (chfile,ch);
  91.     writelog (20,2,ch.choice);
  92.   end;
  93.  
  94.   procedure getvote (mandatory:boolean);
  95.   var cnt,chn:integer;
  96.       k:char;
  97.       ch:choicerec;
  98.       tmp:lstr;
  99.       a:boolean;
  100.   begin
  101.     if urec.voted[curtopicnum]<>0 then begin
  102.       writeln ('Sorry, can''t vote twice!!');
  103.       exit
  104.     end;
  105.     a:=ulvl>=curtopic.addlevel;
  106.     tmp:=#13+#13+'Your choice [?=List';
  107.     if a then tmp:=tmp+', A to add';
  108.     tmp:=tmp+']:';
  109.     repeat
  110.       writestr (tmp);
  111.       if (length(input)=0) or hungupon then exit;
  112.       chn:=valu(input);
  113.       if chn=0 then begin
  114.         k:=upcase(input[1]);
  115.         if k='?'
  116.           then listchoices
  117.           else if k='A'
  118.             then if a
  119.               then chn:=addchoice
  120.               else writestr ('You may not add choices to this topic!')
  121.       end
  122.     until chn<>0;
  123.     if (chn>numchoices) or (chn<0) then begin
  124.       writeln ('Choice number out of range!');
  125.       exit
  126.     end;
  127.     curtopic.numvoted:=curtopic.numvoted+1;
  128.     writecurtopic;
  129.     seek (chfile,chn-1);
  130.     read (chfile,ch);
  131.     ch.numvoted:=ch.numvoted+1;
  132.     seek (chfile,chn-1);
  133.     write (chfile,ch);
  134.     urec.voted[curtopicnum]:=chn;
  135.     writeurec;
  136.     writeln (^M^S'Thanks for voting!')
  137.   end;
  138.  
  139.   procedure showresults;
  140.   var cnt,tpos,n:integer;
  141.       ch:choicerec;
  142.       percent:real;
  143.   begin
  144.     if urec.voted[curtopicnum]=0 then begin
  145.       writeln (^M'Sorry, you must vote first!');
  146.       exit
  147.     end;
  148.     seek (chfile,0);
  149.     tpos:=1;
  150.     for cnt:=1 to filesize (chfile) do begin
  151.       read (chfile,ch);
  152.       n:=length(ch.choice)+2;
  153.       if n>tpos then tpos:=n
  154.     end;
  155.     clearscr;
  156.     writehdr ('The results so far');
  157.     seek (chfile,0);
  158.     for cnt:=1 to numchoices do if not break then begin
  159.       read (chfile,ch);
  160.       tab (ch.choice,tpos);
  161.       writeln (ch.numvoted)
  162.     end;
  163.     if numusers>0
  164.       then percent:=100.0*curtopic.numvoted/numusers
  165.       else percent:=0;
  166.     writeln (^M,percent:0:0,'% of ',numusers,' have voted.')
  167.   end;
  168.  
  169.   procedure listtopics;
  170.   var t:topicrec;
  171.       cnt:integer;
  172.   begin
  173.     writehdr ('Voting Topics');
  174.     seek (tofile,0);
  175.     for cnt:=1 to numtopics do
  176.       if not break then begin
  177.         read (tofile,t);
  178.         writeln (cnt:2,'.  ',t.topicname)
  179.       end
  180.   end;
  181.  
  182.   procedure addtopic;
  183.   var t:topicrec;
  184.       ch:choicerec;
  185.       u:userrec;
  186.       cnt,tpn:integer;
  187.   begin
  188.     if numtopics>=maxtopics then
  189.       begin
  190.         writeln ('No more room to add a topic!');
  191.         exit
  192.       end;
  193.     tpn:=numtopics+1;
  194.     writestr (^M'Topic name:');
  195.     if length(input)=0 then exit;
  196.     t.topicname:=input;
  197.     t.numvoted:=0;
  198.     writeurec;
  199.     for cnt:=1 to numusers do begin
  200.       seek (ufile,cnt);
  201.       read (ufile,u);
  202.       if u.voted[tpn]<>0
  203.         then
  204.           begin
  205.             u.voted[tpn]:=0;
  206.             seek (ufile,cnt);
  207.             write (ufile,u)
  208.           end
  209.     end;
  210.     readurec;
  211.     writestr (^M'Make all users vote on this topic? *');
  212.     t.mandatory:=yes;
  213.     writestr ('Allow users to add their own choices? *');
  214.     if yes then begin
  215.       writestr ('Level required to add choices? *');
  216.       t.addlevel:=valu(input)
  217.     end else t.addlevel:=maxint;
  218.     seek (tofile,tpn-1);
  219.     write (tofile,t);
  220.     opentopic (tpn);
  221.     writeln (^M^B'Enter choices, blank line to end.');
  222.     cnt:=1;
  223.     repeat
  224.       buflen:=70;
  225.       writestr ('Choice number '+strr(cnt)+': &');
  226.       if length(input)>0 then begin
  227.         cnt:=cnt+1;
  228.         ch.numvoted:=0;
  229.         ch.choice:=input;
  230.         write (chfile,ch)
  231.       end
  232.     until (length(input)=0) or hungupon;
  233.     writeln ('Topic created!');
  234.     writelog (20,3,strr(tpn)+' ('+t.topicname+')')
  235.   end;
  236.  
  237.   procedure maybeaddtopic;
  238.   begin
  239.     writestr ('Create new topic? *');
  240.     if yes then addtopic
  241.   end;
  242.  
  243.   procedure selecttopic;
  244.   var ch:integer;
  245.   begin
  246.     input:=copy(input,2,255);
  247.     if input='' then input:=' ';
  248.     repeat
  249.       if length(input)=0 then exit;
  250.       ch:=valu(input);
  251.       if ch>numtopics then begin
  252.         ch:=numtopics+1;
  253.         if issysop then maybeaddtopic;
  254.         if numtopics<>ch then exit
  255.       end;
  256.       if (ch<1) or (ch>numtopics) then begin
  257.         if input='?' then listtopics;
  258.         writestr (^M'Topic number [?=list]:');
  259.         ch:=0
  260.       end
  261.     until (ch>0) or hungupon;
  262.     opentopic (ch)
  263.   end;
  264.  
  265.   procedure deltopic;
  266.   var un,cnt:integer;
  267.       u:userrec;
  268.       f:file;
  269.       t:topicrec;
  270.       tn:lstr;
  271.   begin
  272.     tn:=' topic '+strr(curtopicnum)+' ('+curtopic.topicname+')';
  273.     writestr ('Delete topic '+tn+'? *');
  274.     if not yes then exit;
  275.     writelog (20,1,tn);
  276.     close (chfile);
  277.     erase (chfile);
  278.     cnt:=ioresult;
  279.     for cnt:=curtopicnum to numtopics-1 do begin
  280.       assign (f,votefn(cnt+1));
  281.       rename (f,votefn(cnt));
  282.       un:=ioresult;
  283.       seek (tofile,cnt);
  284.       read (tofile,t);
  285.       seek (tofile,cnt-1);
  286.       write (tofile,t)
  287.     end;
  288.     seek (tofile,numtopics-1);
  289.     truncate (tofile);
  290.     if curtopicnum<numtopics then begin
  291.       writeln ('Adjusting user voting record...');
  292.       writeurec;
  293.       for un:=1 to numusers do begin
  294.         seek (ufile,un);
  295.         read (ufile,u);
  296.         for cnt:=curtopicnum to numtopics do
  297.           u.voted[cnt]:=u.voted[cnt+1];
  298.         seek (ufile,un);
  299.         write (ufile,u)
  300.       end;
  301.       readurec
  302.     end;
  303.     if numtopics>0 then opentopic (1)
  304.   end;
  305.  
  306.   procedure removechoice;
  307.   var n:integer;
  308.       delled,c:choicerec;
  309.       cnt:integer;
  310.       u:userrec;
  311.   begin
  312.     n:=valu(copy(input,2,255));
  313.     if (n<1) or (n>numchoices) then n:=0;
  314.     while n=0 do begin
  315.       writestr (^M'Choice to delete [?=list]:');
  316.       n:=valu(input);
  317.       if n=0
  318.         then if input='?'
  319.           then listchoices
  320.           else exit
  321.     end;
  322.     if (n<1) or (n>numchoices) then exit;
  323.     seek (chfile,n-1);
  324.     read (chfile,delled);
  325.     for cnt:=n to numchoices-1 do begin
  326.       seek (chfile,cnt);
  327.       read (chfile,c);
  328.       seek (chfile,cnt-1);
  329.       write (chfile,c)
  330.     end;
  331.     seek (chfile,numchoices-1);
  332.     truncate (chfile);
  333.     curtopic.numvoted:=curtopic.numvoted-delled.numvoted;
  334.     writecurtopic;
  335.     write (^B^M'Choice deleted; updating user voting records...');
  336.     writeurec;
  337.     for cnt:=1 to numusers do begin
  338.       seek (ufile,cnt);
  339.       read (ufile,u);
  340.       u.voted[curtopicnum]:=0;
  341.       seek (ufile,cnt);
  342.       write (ufile,u)
  343.     end;
  344.     readurec;
  345.     writeln (^B'Done.')
  346.   end;
  347.  
  348.   procedure nexttopic;
  349.   begin
  350.     if curtopicnum=numtopics
  351.       then writeln ('No more topics!')
  352.       else opentopic (curtopicnum+1)
  353.   end;
  354.  
  355.   procedure voteonmandatory;
  356.   var n:integer;
  357.       t:topicrec;
  358.   begin
  359.     for n:=1 to numtopics do
  360.       if urec.voted[n]=0 then begin
  361.         seek (tofile,n-1);
  362.         read (tofile,t);
  363.         if t.mandatory then begin
  364.           opentopic (n);
  365.           clearbreak;
  366.           nobreak:=true;
  367.           writeln (^M'Mandatory voting topic: ',t.topicname,^M);
  368.           listchoices;
  369.           getvote (true);
  370.           if urec.voted[curtopicnum]<>0 then begin
  371.             writestr (^M'See results? *');
  372.             if yes then showresults
  373.           end
  374.         end
  375.       end
  376.   end;
  377.  
  378.   procedure sysopvoting;
  379.   var q,dum:integer;
  380.   begin
  381.     writelog (19,1,curtopic.topicname);
  382.     repeat
  383.       q:=menu ('Voting sysop','VSYSOP','QACDR');
  384.       if hungupon then exit;
  385.       case q of
  386.         2:addtopic;
  387.         3:dum:=addchoice;
  388.         4:deltopic;
  389.         5:removechoice;
  390.       end
  391.     until (q=1) or hungupon or (numtopics=0)
  392.   end;
  393.  
  394. var q:integer;
  395. label exit;
  396. begin
  397.   cursection:=votingsysop;
  398.   opentopicdir;
  399.   repeat
  400.    if numtopics=0 then begin
  401.      if getmandatory then goto exit;
  402.      writeln ('No voting topics right now!');
  403.      if not issysop then goto exit else begin
  404.        writestr ('Create Voting Topic #1 [y/n]? *');
  405.        if yes then addtopic  else goto exit
  406.      end;
  407.    end;
  408.   until (numtopics>0) or hungupon;
  409.   if hungupon then goto exit;
  410.   if getmandatory then begin
  411.     voteonmandatory;
  412.     goto exit
  413.   end;
  414.   opentopic (1);
  415.   writehdr ('The Voting Booths');
  416.   writeln ('Number of topics: ',numtopics);
  417.   repeat
  418.    writeln (^M'Active topic (',curtopicnum,'): ',curtopic.topicname);
  419.    q:=menu ('Voting','VOTING','QS_VLR#*H%@');
  420.    if hungupon then goto exit;
  421.    if q<0 then begin
  422.      q:=-q;
  423.      if q<=numtopics then opentopic (q);
  424.      q:=0
  425.    end else
  426.    case q of
  427.     2,8:selecttopic;
  428.     3:nexttopic;
  429.     4:getvote (false);
  430.     5:listchoices;
  431.     6:showresults;
  432.     9:help ('Voting.hlp');
  433.     10:sysopvoting
  434.    end
  435.   until (q=1) or hungupon or (numtopics=0);
  436.   if numtopics=0 then writeln (^B'No voting topics right now!');
  437.   exit:
  438.   close (tofile);
  439.   close (chfile)
  440. end;
  441.  
  442. begin
  443. end.